home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / f2c / may_5_92.lha / f2c.VMay_5_1992 / src / gram.head < prev    next >
Text File  |  1992-05-07  |  8KB  |  300 lines
  1. /****************************************************************
  2. Copyright 1990 by AT&T Bell Laboratories, Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. %{
  25. #    include "defs.h"
  26. #    include "p1defs.h"
  27.  
  28. static int nstars;            /* Number of labels in an
  29.                        alternate return CALL */
  30. static int datagripe;
  31. static int ndim;
  32. static int vartype;
  33. int new_dcl;
  34. static ftnint varleng;
  35. static struct Dims dims[MAXDIM+1];
  36. static struct Labelblock *labarray[MAXLABLIST];    /* Labels in an alternate
  37.                            return CALL */
  38.  
  39. /* The next two variables are used to verify that each statement might be reached
  40.    during runtime.   lastwasbranch   is tested only in the defintion of the
  41.    stat:   nonterminal. */
  42.  
  43. int lastwasbranch = NO;
  44. static int thiswasbranch = NO;
  45. extern ftnint yystno;
  46. extern flag intonly;
  47. static chainp datastack;
  48. extern long laststfcn, thisstno;
  49. extern int can_include;    /* for netlib */
  50.  
  51. ftnint convci();
  52. Addrp nextdata();
  53. expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
  54. expptr mkcxcon();
  55. struct Listblock *mklist();
  56. struct Listblock *mklist();
  57. struct Impldoblock *mkiodo();
  58. Extsym *comblock();
  59. #define ESNULL (Extsym *)0
  60. #define NPNULL (Namep)0
  61. #define LBNULL (struct Listblock *)0
  62. extern void freetemps(), make_param();
  63.  
  64.  static void
  65. pop_datastack() {
  66.     chainp d0 = datastack;
  67.     if (d0->datap)
  68.         curdtp = (chainp)d0->datap;
  69.     datastack = d0->nextp;
  70.     d0->nextp = 0;
  71.     frchain(&d0);
  72.     }
  73.  
  74. %}
  75.  
  76. /* Specify precedences and associativities. */
  77.  
  78. %union    {
  79.     int ival;
  80.     ftnint lval;
  81.     char *charpval;
  82.     chainp chval;
  83.     tagptr tagval;
  84.     expptr expval;
  85.     struct Labelblock *labval;
  86.     struct Nameblock *namval;
  87.     struct Eqvchain *eqvval;
  88.     Extsym *extval;
  89.     }
  90.  
  91. %left SCOMMA
  92. %nonassoc SCOLON
  93. %right SEQUALS
  94. %left SEQV SNEQV
  95. %left SOR
  96. %left SAND
  97. %left SNOT
  98. %nonassoc SLT SGT SLE SGE SEQ SNE
  99. %left SCONCAT
  100. %left SPLUS SMINUS
  101. %left SSTAR SSLASH
  102. %right SPOWER
  103.  
  104. %start program
  105. %type <labval> thislabel label assignlabel
  106. %type <tagval> other inelt
  107. %type <ival> type typespec typename dcl letter addop relop stop nameeq
  108. %type <lval> lengspec
  109. %type <charpval> filename
  110. %type <chval> datavar datavarlist namelistlist funarglist funargs
  111. %type <chval> dospec dospecw
  112. %type <chval> callarglist arglist args exprlist inlist outlist out2 substring
  113. %type <namval> name arg call var
  114. %type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
  115. %type <expval> ubound simple value callarg complex_const simple_const bit_const
  116. %type <extval> common comblock entryname progname
  117. %type <eqvval> equivlist
  118.  
  119. %%
  120.  
  121. program:
  122.     | program stat SEOS
  123.     ;
  124.  
  125. stat:      thislabel  entry
  126.         {
  127. /* stat:   is the nonterminal for Fortran statements */
  128.  
  129.           lastwasbranch = NO; }
  130.     | thislabel  spec
  131.     | thislabel  exec
  132.         { /* forbid further statement function definitions... */
  133.           if (parstate == INDATA && laststfcn != thisstno)
  134.             parstate = INEXEC;
  135.           thisstno++;
  136.           if($1 && ($1->labelno==dorange))
  137.             enddo($1->labelno);
  138.           if(lastwasbranch && thislabel==NULL)
  139.             warn("statement cannot be reached");
  140.           lastwasbranch = thiswasbranch;
  141.           thiswasbranch = NO;
  142.           if($1)
  143.             {
  144.             if($1->labtype == LABFORMAT)
  145.                 err("label already that of a format");
  146.             else
  147.                 $1->labtype = LABEXEC;
  148.             }
  149.           freetemps();
  150.         }
  151.     | thislabel SINCLUDE filename
  152.         { if (can_include)
  153.             doinclude( $3 );
  154.           else {
  155.             fprintf(diagfile, "Cannot open file %s\n", $3);
  156.             done(1);
  157.             }
  158.         }
  159.     | thislabel  SEND  end_spec
  160.         { if ($1)
  161.             lastwasbranch = NO;
  162.           endproc(); /* lastwasbranch = NO; -- set in endproc() */
  163.         }
  164.     | thislabel SUNKNOWN
  165.         { extern void unclassifiable();
  166.           unclassifiable();
  167.  
  168. /* flline flushes the current line, ignoring the rest of the text there */
  169.  
  170.           flline(); };
  171.     | error
  172.         { flline();  needkwd = NO;  inioctl = NO;
  173.           yyerrok; yyclearin; }
  174.     ;
  175.  
  176. thislabel:  SLABEL
  177.         {
  178.         if(yystno != 0)
  179.             {
  180.             $$ = thislabel =  mklabel(yystno);
  181.             if( ! headerdone ) {
  182.                 if (procclass == CLUNKNOWN)
  183.                     procclass = CLMAIN;
  184.                 puthead(CNULL, procclass);
  185.                 }
  186.             if(thislabel->labdefined)
  187.                 execerr("label %s already defined",
  188.                     convic(thislabel->stateno) );
  189.             else    {
  190.                 if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
  191.                     && thislabel->labtype!=LABFORMAT)
  192.                     warn1("there is a branch to label %s from outside block",
  193.                           convic( (ftnint) (thislabel->stateno) ) );
  194.                 thislabel->blklevel = blklevel;
  195.                 thislabel->labdefined = YES;
  196.                 if(thislabel->labtype != LABFORMAT)
  197.                     p1_label((long)(thislabel - labeltab));
  198.                 }
  199.             }
  200.         else    $$ = thislabel = NULL;
  201.         }
  202.     ;
  203.  
  204. entry:      SPROGRAM new_proc progname
  205.            {startproc($3, CLMAIN); }
  206.     | SPROGRAM new_proc progname progarglist
  207.            {    warn("ignoring arguments to main program");
  208.             /* hashclear(); */
  209.             startproc($3, CLMAIN); }
  210.     | SBLOCK new_proc progname
  211.         { if($3) NO66("named BLOCKDATA");
  212.           startproc($3, CLBLOCK); }
  213.     | SSUBROUTINE new_proc entryname arglist
  214.         { entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
  215.     | SFUNCTION new_proc entryname arglist
  216.         { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
  217.     | type SFUNCTION new_proc entryname arglist
  218.         { entrypt(CLPROC, $1, varleng, $4, $5); }
  219.     | SENTRY entryname arglist
  220.          { if(parstate==OUTSIDE || procclass==CLMAIN
  221.             || procclass==CLBLOCK)
  222.                 execerr("misplaced entry statement", CNULL);
  223.           entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
  224.         }
  225.     ;
  226.  
  227. new_proc:
  228.         { newproc(); }
  229.     ;
  230.  
  231. entryname:  name
  232.         { $$ = newentry($1, 1); }
  233.     ;
  234.  
  235. name:      SNAME
  236.         { $$ = mkname(token); }
  237.     ;
  238.  
  239. progname:        { $$ = NULL; }
  240.     | entryname
  241.     ;
  242.  
  243. progarglist:
  244.       SLPAR SRPAR
  245.     | SLPAR progargs SRPAR
  246.     ;
  247.  
  248. progargs: progarg
  249.     | progargs SCOMMA progarg
  250.     ;
  251.  
  252. progarg:  SNAME
  253.     | SNAME SEQUALS SNAME
  254.     ;
  255.  
  256. arglist:
  257.         { $$ = 0; }
  258.     | SLPAR SRPAR
  259.         { NO66(" () argument list");
  260.           $$ = 0; }
  261.     | SLPAR args SRPAR
  262.         {$$ = $2; }
  263.     ;
  264.  
  265. args:      arg
  266.         { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
  267.     | args SCOMMA arg
  268.         { if($3) $1 = $$ = mkchain((char *)$3, $1); }
  269.     ;
  270.  
  271. arg:      name
  272.         { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
  273.             dclerr("name declared as argument after use", $1);
  274.           $1->vstg = STGARG;
  275.         }
  276.     | SSTAR
  277.         { NO66("altenate return argument");
  278.  
  279. /* substars   means that '*'ed formal parameters should be replaced.
  280.    This is used to specify alternate return labels; in theory, only
  281.    parameter slots which have '*' should accept the statement labels.
  282.    This compiler chooses to ignore the '*'s in the formal declaration, and
  283.    always return the proper value anyway.
  284.  
  285.    This variable is only referred to in   proc.c   */
  286.  
  287.           $$ = 0;  substars = YES; }
  288.     ;
  289.  
  290.  
  291.  
  292. filename:   SHOLLERITH
  293.         {
  294.         char *s;
  295.         s = copyn(toklen+1, token);
  296.         s[toklen] = '\0';
  297.         $$ = s;
  298.         }
  299.     ;
  300.